{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

program test;


Uses
  Crt, {Unit found in TURBO.TPL}
  Dos, {Unit found in TURBO.TPL}
  Printer; {Unit found in TURBO.TPL}

const
   maxntestmax  = 100;    (* numero de tests a realizar *)
   maxnmax      = 50;     (* numero de preguntas en la base *)
   maxmmax      = 5;      (* numero de respuestas por pregunta *)
   maxnpre      = 50;     (* numero de preguntas de un test *)
   maxmres      = 5;      (* numero de respuestas de un test = nmax *)

type
   tipolinea     = string [255];
   tipopregunta  = string [255];
   tiporespuesta = string [128];
var
   ntestmax  : integer;    (* numero de tests a realizar *)
   nmax      : integer;    (* numero de preguntas en la base *)
   mmax      : integer;    (* numero de respuestas por pregunta *)
   npre      : integer;    (* numero de preguntas de un test *)
   mres      : integer;    (* numero de respuestas de un test = nmax *)
   nprepag   : integer;    (* Numero de preguntaspor pagina *)
   fecha     : string[30];
   fichero   : string[14];
   pregunta  : array [1..maxnmax] of tipopregunta;
   respuesta : array [1..maxnmax,1..maxmmax] of tiporespuesta;
   n,m       : integer;
   ntest     : integer;
   solucion  : array [1..maxntestmax,1..maxnpre] of char;
   _rnd      : real; (* semilla = 35.78921  *)

   lst       : text;



(****************************************************************)

function segundos: integer;
type
  regpack = record
              ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
{! 1. Instead use the Registers type from the Turbo 5.0^ DOS unit.}
            end;
var
  recpack:          regpack;             {assign record}
  ah,al,ch,cl,dh:   byte;

begin
  ah := $2c;                             {initialize correct registers}
  with recpack do
  begin
    ax := ah shl 8 + al;
  end;
  intr($21,Dos.Registers(recpack));                     {call interrupt}
{! 2. Param^eter to Intr must be of the type Registers defined in DOS unit.}
  with recpack do
    segundos:= (dx shr 8);               { " }
end;

(****************************************************************)

function rnd : real;
begin _rnd:=123.321*_rnd; _rnd:=_rnd-int(_rnd); rnd:=_rnd end;

(****************************************************************)

procedure Nuevapagina;
var i : integer;
begin
write(lst,#12);
  writeln(lst,fecha,'                         PROCESADORES DE LENGUAJES');
  for i:=1 to 79 do write(lst,'-');writeln(lst);
  writeln(lst,'Test Numero : ',ntest,'                  Nombre : ');
  for i:=1 to 79 do write(lst,'-');writeln(lst);
  write(lst,'Respuestas   ');
  for i:=n to n+nprepag-1 do write(lst,i:2,' :    ');writeln(lst);
  for i:=1 to 79 do write(lst,'-');writeln(lst);
end;

(****************************************************************)


procedure cortarlinea(linea:tipolinea; longitud:integer;
                       var linea1,linea2 : tipolinea);
var i,j : integer;
begin
if length(linea)<=longitud then
  begin
   linea1:=linea;
   linea2:='';
  end
  else begin
    i:=longitud+1;
    while linea[i]<>' ' do i:=i-1;
    linea1:=copy(linea,1,i);
    linea2:=copy(linea,i+1,length(linea)-i);
  end;
end;


(****************************************************************)
procedure Parametros;   (* Este procedimiento no se usa *)
var ch: char;
begin

clrscr;
write('Tipo de examen y fecha                         : ');readln(fecha);
write('Fichero de la base de preguntas                : ');readln(fichero);
write('Parametros habituales  (S/N)                   : ');readln(ch);
if upcase(ch)='N'
  then begin
    write('Numero de preguntas en la base                 : ');readln(nmax);
    write('Numero de respuestas por pregunta              : ');readln(mmax);
    write('Numero de test a realizar                      : ');readln(ntestmax);
    write('Numero de preguntas de un test                 : ');readln(npre);
    (* write('Numero de respuestas por pregunta en el test   : ');readln(mres); *) mres:=mmax;
    write('Numero de preguntas por pagina                 : ');readln(nprepag);
    write('Semilla para la generacion aleatoria           : ');readln(_rnd);
  end
  else begin
    nmax:=10;
    mmax:=4;
    ntestmax:=5;
    npre:=10;
    mres:=mmax;
    nprepag:=5;
    _rnd:=0;
  end;
_rnd:=35.78921+_rnd;
write('--------------------------------------------------------');

end;

(****************************************************************)

procedure Leer;
var
  test : text;
  i,j  : integer;
  comentario : string[40];

begin
  assign(test,'TEST.DOC');
  reset (test);
  readln(test);
  readln(test,comentario,fecha);
  readln(test,comentario,nmax);
  readln(test,comentario,mmax);
  readln(test,comentario,ntestmax);
  readln(test,comentario,npre);
  readln(test,comentario,nprepag);
  readln(test);
  mres :=mmax;
  _rnd := 3.1415972+segundos;
  for i:=1 to nmax do
    begin
      readln(test,pregunta[i]);
      for j:=1 to mmax do
         readln(test,respuesta[i,j]);
      readln(test);
    end;
  close(test);
end;

(*****************************************************************)

procedure Escribirpregunta(n,i : integer);
var   linea,linea1 : tipolinea;
begin
  writeln(lst);
  writeln(lst);
  linea:=pregunta[i];
  cortarlinea(linea,62,linea1,linea);
  writeln(lst,'    ',n:2,')  ',linea1);
  while linea<>'' do
    begin
      cortarlinea(linea,62,linea1,linea);
      writeln(lst,'         ',linea1);
    end;
  writeln(lst);
end;

(*****************************************************************)

procedure EscribirRespuesta (m,i,j : integer);
const margen = '         ';
var   linea,linea1 : tipolinea;
begin
  linea:=respuesta[i,j];
  cortarlinea(linea,59,linea1,linea);
  writeln(lst,margen,chr(64+m), ') ',linea1);
  while linea<>'' do
    begin
      cortarlinea(linea,59,linea1,linea);
      writeln(lst,margen,'   ',linea1);
    end;
end;


(*****************************************************************)
procedure EscribirSoluciones;
var ntest,i : integer;
begin
writeln(lst,#12); (* salto de pagina *)
for i:=1 to 79 do write(lst,'-');writeln(lst);
for ntest:=1 to ntestmax do
  begin
     write(lst,ntest:10,'      ');
     for i:=1 to npre do 
       begin
         write(lst,solucion[ntest,i]);
         if (i mod nprepag)=0 then write(lst,' ');
       end;
     writeln(lst);
     for i:=1 to 79 do write(lst,'-');writeln(lst);
  end;
end;

(*******************************************************************)

procedure EscribirTest(ntest: integer);
var i,j  : integer;
    cres : set of 1..maxmmax;
    cpre : set of 1..maxnmax;
begin
  cpre:=[];
  for n:=1 to npre do
    begin
     if (n mod nprepag)=1 then Nuevapagina;
     repeat
        i:=round(int(rnd*nmax))+1;
     until not(i in cpre);
     cpre:=cpre+[i];
     EscribirPregunta(n,i);
     cres:=[];
     for m:=1 to mres do
      begin
        repeat
          j:=round(int(rnd*mmax))+1;
        until not(j in cres);
        cres:=cres+[j];
        EscribirRespuesta(m,i,j);
        if j=1 then solucion[ntest,n]:=chr(64+m);
      end; (* m *);
    end;  (* n *)
end; (* EscribirTest *)

(*********************************************************************)

procedure EscribirMaestro;
begin
  ntest:=0;
  for n:=1 to npre do
    begin
     if (n mod nprepag)=1 then Nuevapagina;
     EscribirPregunta(n,n);
     for m:=1 to mres do
      begin
        EscribirRespuesta(m,n,m);
      end; (* m *);
    end;  (* n *)
end; (* EscribirMaestro *)

(*********************************************************************)
(*********************************************************************)

begin
(* Parametros; *)
assign(lst,'TEST.TXT');
rewrite(lst);
Leer;
if (ntestmax = 0) then EscribirMaestro;
for ntest:=1 to ntestmax do
  EscribirTest(ntest);
Escribirsoluciones;
write(lst,#12);
close(lst);
end.
